home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / dbase / vpi1_330.zip / REGISTER.PRG < prev    next >
Text File  |  1992-01-03  |  16KB  |  512 lines
  1. *************************************************************************
  2. **  REGISTER.PRG
  3. **  (C) Copyright 1990-91, Sub Rosa Publishing Inc.
  4. **
  5. **  A demonstration program provided to VP-Info users.
  6. **  This program may be copied freely. If it is used in commercial code,
  7. **  please credit the source, Sub Rosa Publishing Inc.
  8. **
  9. **  REGISTER demonstrates the use of the VP-Info in filling out and
  10. **  printing a standard form...in this case, a registration for for
  11. **  VP-Info Level 1.  Full documentation may be found by running
  12. **  SAMPLES program.
  13. **
  14. **  REGISTER is compatible with all current versions of VP-Info.
  15. **
  16. **  Sid Bursten and Bernie Melman
  17. ***************************************************************************
  18. SET function off ; we want the raw function keys - not the pre-loaded messages.
  19. SET text off     ; reset this to default...turn on only when needed
  20. SET trim off     ; do not have output macros (&-type) automatically trimmed
  21. SET upper on     ; force all keyboard input to capital letters
  22. SET exact off    ; ensure default in use for comparisons
  23. ON escape
  24.    :color=:serial    ;restores default color to what it was on entry
  25.    WINDOW
  26.    CURSOR 22,0
  27.    SET text off
  28.    SET upper off
  29.    SET function on
  30.    CANCEL
  31. ENDON
  32. DIM num look[10]           ;declare an array for credit card validation
  33. REPEAT 5 times varying nn  ;initialize its values in a loop
  34.    look[nn]=nn*2-2
  35.    look[nn+5]=nn*2-1
  36. ENDREPEAT
  37. DIM char 25 message[6]     ;declare an array for messages and fill it
  38. message[1]='5.25-inch disks'
  39. message[2]='3.5-inch disks'
  40. message[3]='VISA Credit Card'
  41. message[4]='MasterCard'
  42. message[5]='Check or Money Order'
  43. message[6]='Company Purchase Order'
  44. ************************* set up colors properly ********************
  45. DIM num ncolor[5],rcolor[5]
  46. IF type(:serial)<>'N'
  47.    :serial=:color
  48. ENDIF
  49. IF :serial<>7     ;color monitor in use
  50.    ncolor[1]= 62     ; yellow on green
  51.    rcolor[1]= 99
  52.    ncolor[2]=107     ; blue on brown
  53.    rcolor[2]= 56
  54.    ncolor[3]= 31     ; white on blue
  55.    rcolor[3]=113
  56.    ncolor[4]=111     ; white on blue
  57.    rcolor[4]=119
  58. ELSE
  59.    ncolor[1]=7
  60.    rcolor[1]=112
  61.    ncolor[2]=7
  62.    rcolor[2]=112
  63.    ncolor[3]=7
  64.    rcolor[3]=112
  65.    ncolor[4]=7
  66.    rcolor[4]=112
  67. ENDIF
  68. :color=ncolor[4]
  69. ********* define variables we need customer to fill in ********
  70. name=blank(30)
  71. company=blank(30)
  72. add1=blank(30)
  73. add2=blank(30)
  74. city=blank(20)
  75. state=blank(2)
  76. fstate=blank(6)
  77. zip=blank(10)
  78. country=blank(15)
  79. phone=blank(10)
  80. hphone=blank(10)
  81. fax=blank(10)
  82. shiptoname=blank(30)
  83. shiptocomp=blank(30)
  84. shiptoadd1=blank(30)
  85. shiptoadd2=blank(30)
  86. shiptocity=blank(20)
  87. shiptost=blank(2)
  88. shiptozip=blank(10)
  89. fshipstate=blank(6)
  90. shiptocnt=blank(15)
  91. disktype=0
  92. cardtype=0
  93. cardnum=blank(16)
  94. cardexp=blank(4)
  95. cardname=blank(30)
  96. ******************* initialize variables needed internally ********
  97. qty1=0
  98. qty2=0
  99. qty3=0
  100. qty4=0
  101. qty5=0
  102. qty6=0
  103. qty7=0
  104. qty8=0
  105. qty9=0
  106. tot1=0
  107. tot2=0
  108. tot3=0
  109. tot4=0
  110. tot5=0
  111. tot6=0
  112. tot7=0
  113. tot8=0
  114. tot9=0
  115. price1=100
  116. IF date(1)>'9202' ;introductory prices end effective March 1/92
  117.    price2=295
  118.    price3=649
  119.    price4=649
  120.    price5=995
  121. ELSE
  122.    price2=189
  123.    price3=289
  124.    price4=369
  125.    price5=569
  126. ENDIF
  127. price6=35
  128. price7=189
  129. price8=25
  130. price9=40
  131. ship=0
  132. mintax=0
  133. onttax=0
  134. gst=0
  135. total=0
  136. city_state=0
  137. cl=0
  138. cn=0
  139. csum=0
  140. digit=0
  141. disksize=0
  142. doublemod=0
  143. expiry=' '
  144. merror=0
  145. ok=0
  146. paytype=0
  147. provinces='BC,AB,SK,MN,ON,QC,PE,NB,NS,NF,YT,NT'
  148. scr_name=' '
  149. screen=0
  150. selection=0
  151. shiptoc_s=0
  152. total2=0
  153. valid=t
  154. *********************** start the program itself ********************
  155. DO WHILE t                    ;put main menu in an infinite loop
  156.    SET WIDTH to 80
  157.    IF disktype=0        ;no need for menu when no information yet entered
  158.       selection=1
  159.    ELSE
  160.       SCREEN 2
  161.       screen=4
  162.       :color=ncolor[screen]
  163.       COLOR :color,0,0,24,79,177    ;fill screen with pattern
  164. *                                   ;  177 is the fill character '▒'.
  165.       COLOR 128,7,15,21,70          ;draw black box to become shadow
  166.       WINDOW 6,12,19,67 DOUBLE color :color   ;declare space for menu text
  167.       TEXT
  168.  
  169.          VP-INFO REGISTRATION & ORDER MENU
  170.  
  171.      0. Exit to Sample Programs Menu
  172.  
  173.      1. Fill in VP-Info Registration/Order Form
  174.      2. Print Completed Order
  175.       ENDTEXT
  176.       CURSOR 12,15 ; positions menu cursor over 1st character of 1st choice
  177.       SCREEN 1
  178.       SCREEN up
  179.       selection=menu(2,47)      ;two choices, menu bar width 47
  180.    ENDIF
  181.    DO CASE
  182.    CASE selection=0 .or. :key=327  ; <home> key
  183.       WINDOW
  184.       SET function on
  185.       SET text off
  186.       SET upper off
  187.       :color=:serial    ;restores default color to what it was on entry
  188.       CHAIN samples
  189.    CASE selection=1
  190.       SET text on      ; allows output macros to be dynamically updated
  191.       SET width to 80  ; stops wide text from "wrapping"
  192.       screen=1
  193.       disktype=1       ; reset here to force menu to come up on <End>
  194.       DO WHILE t
  195.          scr_name='order.in'+str(screen,1)
  196.          SCREEN 2
  197.          WINDOW
  198.          :color=ncolor[screen]
  199.          CLS
  200.          CLEAR gets
  201.          TEXT &scr_name
  202.          CURSOR 23,0
  203.          TEXT
  204.  1 Screen 1 \2192 Screen 2 \2193 Screen 3 \2194  \2195  \2196  \2197  \2198  \2199  \21910 Next Screen
  205.          ENDTEXT
  206.          COLOR ncolor[3],23,0,24,79
  207.          COLOR rcolor[3],24,1,24,78
  208.          DO CASE
  209.          CASE screen=1
  210.             ON field
  211.             FIELD name
  212.                :field=field(company)
  213.             FIELD company
  214.                IF company=' ' .and. name=' '
  215.                   :field=field(name)
  216.                   @ 22,0 say cen('Must specify at least NAME or COMPANY.',80)
  217.                   RING
  218.                ELSE
  219.                   :field=field(add1)
  220.                   @ 22,0
  221.                ENDIF
  222.             FIELD add1
  223.                :field=field(add2)
  224.             FIELD add2
  225.                :field=field(city)
  226.             FIELD city
  227.                :field=field(state)
  228.             FIELD state
  229.                :field=field(zip)
  230.             FIELD zip
  231.                IF state=' '              ;enter country only if state is
  232.                   :field=field(fstate)  ;  blank. US and Canadian customers
  233.                ELSE                      ;  do not need country filled in.
  234.                   :field=field(phone)
  235.                ENDIF
  236.             FIELD fstate
  237.                :field=field(country)
  238.             FIELD country
  239.                :field=field(phone)
  240.             FIELD phone
  241.                :field=field(hphone)
  242.             FIELD hphone
  243.                :field=field(fax)
  244.             FIELD fax
  245.                :field=field(shiptoname)
  246.             FIELD shiptoname
  247.                :field=field(shiptocomp)
  248.             FIELD shiptocomp
  249.                :field=field(shiptoadd1)
  250.             FIELD shiptoadd1
  251.                IF shiptoadd1=' '
  252.                   :field=65
  253.                ELSE
  254.                   IF shiptocomp=' ' .and. shiptoname=' '
  255.                      :field=field(shiptoname)
  256.                      @ 22,0 say cen('Must specify at least NAME or COMPANY.',80)
  257.                      RING
  258.                   ELSE
  259.                      :field=field(shiptoadd2)
  260.                      @ 22,0
  261.                   ENDIF
  262.                ENDIF
  263.             FIELD shiptoadd2
  264.                :field=field(shiptocity)
  265.             FIELD shiptost
  266.                :field=field(shiptozip)
  267.             FIELD shiptozip              ;skip country when state filled in.
  268.                IF shiptost=' '           ;  same reasons as in 1st column.
  269.                   :field=field(shiptocnt)
  270.                ELSE
  271.                   :field=65              ;get out immediately
  272.                ENDIF
  273.             FIELD shiptocnt
  274.                :field=65                 ;get out immediately
  275.             ENDON
  276.             :field=1
  277.             SCREEN 1
  278.             SCREEN tear
  279.             READ
  280.          CASE screen=2
  281.             ON field
  282.             FIELD qty1
  283.                PERFORM sums
  284.             FIELD qty2
  285.                PERFORM sums
  286.             FIELD qty3
  287.                PERFORM sums
  288.             FIELD qty4
  289.                PERFORM sums
  290.             FIELD qty5
  291.                PERFORM sums
  292.             FIELD qty6
  293.                PERFORM sums
  294.             FIELD qty7
  295.                PERFORM sums
  296.             FIELD qty8
  297.                PERFORM sums
  298.             FIELD qty9
  299.                PERFORM sums
  300.                :field=field(qty9)
  301.                :color=rcolor[screen]
  302.                @ 0,20 say ' PRESS F10 WHEN READY FOR NEXT SCREEN '
  303.                :color=ncolor[screen]
  304.                RING
  305.             ENDON
  306.             :field=1
  307.             SCREEN 1
  308.             SCREEN left
  309.             READ
  310.          CASE screen=3
  311.             IF cardname=' '
  312.                cardname=name
  313.             ENDIF
  314.             merror=0
  315.             ON field
  316.             FIELD cardnum
  317.                PERFORM cardvalid
  318.                IF .not. valid
  319.                   :color=rcolor[screen]
  320.                   @ 5,30 say ' Invalid Card Number '
  321.                   @ 6,30 say ' Press End to Change Choice.'
  322.                   SOUND 1
  323.                   :field=field(cardnum)
  324.                   :color=ncolor[screen]
  325.                ELSE
  326.                   IF cardtype=4
  327.                      :field=field(cardname)
  328.                   ENDIF
  329.                ENDIF
  330.             FIELD cardexp
  331.                merror=0
  332.                IF cardtype<3
  333.                   expiry=right(cardexp,2)+left(cardexp,2)+'28'
  334.                   DO CASE   ;check 1st for valid date, then that it's not past
  335.                   CASE date(ymd,expiry)=' ' ;DATE( returns blank for bad dates
  336.                      :color=rcolor[screen]
  337.                      @ 5,50 say ' Invalid Date '
  338.                      SOUND 1
  339.                      merror=1
  340.                   CASE expiry<left(date(1),4)  ;compares year and month only
  341.                      :color=rcolor[screen]
  342.                      @ 5,50 say ' Card Expired '
  343.                      SOUND 1
  344.                      merror=2
  345.                   ENDCASE
  346.                ENDIF
  347.                IF merror>0
  348.                   DELAY 2
  349.                   :color=ncolor[screen]
  350.                   @ 5,50 say blank(20)
  351.                   :field=field(cardexp)
  352.                ENDIF
  353.             FIELD cardname
  354.                :color=rcolor[screen]
  355.                @ 20,20 say ' PRESS <End> KEY WHEN COMPLETED... '
  356.                :color=ncolor[screen]
  357.                :field=field(cardname)
  358.             ENDON
  359.             SCREEN 1
  360.             @ 5,30 say blank(45)
  361.             @ 6,30 say blank(45)
  362.             SCREEN right
  363.             disktype=0       ; reinitialize type variables so user can fix mistakes
  364.             cardtype=0
  365.             DO WHILE disktype=0
  366.                CURSOR 3,15
  367.                disktype=menu(2,20)
  368.                IF disktype=0
  369.                   disktype=1          ;default disk type is 5.25"
  370.                ENDIF
  371.             ENDDO
  372.             @ disktype+2,14 say chr(16)
  373.             DO WHILE cardtype=0
  374.                CURSOR 8,15
  375.                cardtype=menu(4,60)
  376.             ENDDO
  377.             @ cardtype+7,14 say chr(16)
  378.             IF cardtype=3   ;cash requires no credit card or P.O. number
  379.                :field=field(cardname)
  380.                cardnum=blank(16)
  381.                cardexp=blank(4)
  382.             ENDIF
  383.             @ 20,20 say ' PRESS <End> KEY WHEN COMPLETED... '
  384.             READ
  385.             PERFORM cardvalid   ; do test again to ensure it wasn't bypassed
  386.             IF merror>0 .or. .not. valid
  387.                disktype=0       ; reinitialize type variables
  388.                cardtype=0       ;   so user can fix mistakes
  389.                merror=0
  390.                WINDOW 10,10,16,69 double color rcolor[screen],rcolor[screen]
  391.                WINDOW 10,12,16,67 blank
  392.                TEXT
  393.  
  394.    Error in Credit Card Number. Press any key to make correction.
  395.                ENDTEXT
  396.                WINDOW
  397.                CURSOR 15,39
  398.                ok=inkey()
  399.                :color=ncolor[screen]
  400.                LOOP
  401.             ENDIF
  402.          ENDCASE
  403.          DO CASE
  404.          CASE :key=315
  405.             screen=1
  406.          CASE :key=316
  407.             screen=2
  408.          CASE :key=317
  409.             screen=3
  410.          CASE :key=335
  411.             BREAK
  412.          OTHERWISE
  413.             screen=screen+1   ;cycle through screens
  414.             IF screen>3
  415.                SOUND 1
  416.                screen=1       ;back to beginning
  417.             ENDIF
  418.          ENDCASE
  419.       ENDDO
  420.       SET text off
  421.    CASE selection=2
  422.       IF total>0 .and. cardtype>0 .and. valid  ;check that we're ready to print
  423.          IF .not. printer()                    ;check that printer is ready
  424.             @ 16,20 say cen('No printer on line.',40)
  425.             @ 17,20 say cen('Press a key...',40)
  426.             CURSOR 18,39
  427.             selection=inkey()
  428.          ELSE
  429.             WINDOW
  430.             screen=4
  431.             :color=ncolor[screen]
  432.             CLS
  433.             if state>' '
  434.                city_state=trim(city)+', '+state
  435.             else
  436.                city_state=trim(city)+', '+fstate
  437.             endif
  438.             IF shiptost>' '
  439.                shiptoc_s=trim(shiptocity)+', '+shiptost
  440.             ELSE
  441.                shiptoc_s=shiptocity
  442.             ENDIF
  443.             disksize=message[disktype]
  444.             paytype=message[cardtype+2]
  445.             CLEAR gets
  446.             SET print on
  447.             SET width to 100   ;stop long lines from wrapping
  448.             TEXT order.out
  449.             TEXT order2.out
  450.             SET printer off
  451.             EJECT
  452.             CLS
  453.          ENDIF
  454.       ELSE
  455.          @ 16,20 say cen('No information to print.',40)
  456.          @ 17,20 say cen('Press a key, then select option 1...',40)
  457.          CURSOR 18,39
  458.          selection=inkey()
  459.       ENDIF
  460.    ENDCASE
  461. ENDDO
  462. *
  463. PROCEDURE sums
  464.    tot1=price1*qty1
  465.    tot2=price2*qty2
  466.    tot3=price3*qty3
  467.    tot4=price4*qty4
  468.    tot5=price5*qty5
  469.    tot6=price6*qty6
  470.    tot7=price7*qty7
  471.    tot8=price8*qty8
  472.    tot9=price9*qty9
  473.    total2=tot1+tot2+tot3+tot4+tot5+tot6+tot7+tot8+tot9
  474.    DO CASE
  475.    CASE left(ltrim(shiptost+state),2)='MN'                ;minnesota
  476.       mintax=total2*.07
  477.    CASE @(left(ltrim(shiptost+state),2),provinces)>0      ;Canadian
  478.       gst=(ship+total2)*.07
  479.       IF left(ltrim(shiptost+state),2)='ON'               ;ontario
  480.          onttax=total2*.08
  481.       ENDIF
  482.    ENDCASE
  483.    ship=5+4*(qty1+qty2+qty3+qty4+qty5+qty6+qty7+qty9)     ;shipping costs
  484.    IF country>'   '
  485.       ship=ship*2                                         ;overseas shipping
  486.    ENDIF
  487.    total=total2+ship+mintax+onttax+gst
  488. ENDPROC sums
  489. *
  490. PROCEDURE cardvalid
  491.    IF cardtype>2                     ;if not M or V, accept as valid
  492.       valid=t                        ;initialize return value TRUE
  493.    ELSE
  494.       valid=f                        ;initialize FALSE and do tests
  495.       cn=replace(cardnum#2,' ','')   ;remove embedded spaces
  496.       cl=len(cn)
  497.       IF cn=str(cardtype+3,1) .and. val(cn)>=3*pow(10,cl-1)
  498.          IF (cl=13 .and. cardtype=1) .or. (cl=16 .and. cardtype>0)
  499.             csum=0
  500.             doublemod=mod(cl,2)
  501.             REPEAT cl times varying nn
  502.                digit=val(substr(cn,nn,1))
  503.                csum=csum+iff(mod(nn-1,2)=doublemod,look[digit+1],digit)
  504.             ENDREPEAT
  505.             valid=(mod(csum,10)=0)   ;returns TRUE if checkdigit test works
  506.          ENDIF
  507.       ENDIF
  508.    ENDIF
  509. ENDPROC cardvalid
  510. *
  511. *                  *** end of program REGISTER.PRG ***
  512.